home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Night Owl 6
/
Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso
/
037a
/
pavt110.zip
/
A0DEMO.PAS
next >
Wrap
Pascal/Delphi Source File
|
1991-09-07
|
6KB
|
246 lines
program A_0_Demo; { Demo of Avatar level 0 console using Crt routines }
{ Public Domain. Author: Greg Smith }
{ Modification History: }
{ 09/06/91 First Coding }
{$D-,L-,R-,F-,M 4096,2048,2048}
Uses Dos, Crt, PAvt0;
type
ScreenWord = record
chr : char;
attr : byte;
end;
ScreenPtr = ^Screen;
Screen = Array[1..25,1..80] of ScreenWord;
var
ScrPtr : ScreenPtr; { for direct screen writes }
{$IFDEF VER55}
Function DV_Get_Video_Buffer(cseg:word): word;
begin
if DESQview_version = 0 then DV_Get_Video_Buffer := 0
else
InLine(
$b4/$fe/ { MOV AH,0FEH DV's get video buffer function }
$cd/$10/ { INT 10H Returns ES:DI of alt buffer }
$8c/$c0); { MOV AX,ES Return video buffer }
end; { DV_Get_Video_Buffer }
{$ELSE}
Function DV_Get_Video_Buffer(cseg:word): word; assembler;
asm
MOV ES,cseg { Put current segment into ES }
CALL DESQview_version { Returns AX=0 if not in DV }
TEST AX,AX { In DV? }
JZ @DVGVB_X { Jump if not }
MOV AH,0FEH { DV's get video buffer function }
INT 10H { Returns ES:DI of alt buffer }
MOV AX,ES { Return video buffer }
JMP @DVGVB_E { Exit and return DV buffer }
@DVGVB_X:
MOV AX,cseg { Load old buffer for return to caller }
@DVGVB_E:
end; { DV_Get_Video_Buffer }
{$ENDIF}
Procedure SetScrPtr;
var
sg : word;
begin
if LastMode = 7 then sg := $B000
else sg := $B800;
sg := DV_Get_Video_Buffer(sg);
ScrPtr := Ptr(sg,$0000);
end;
(* Hooks *)
{$F+}
procedure SetXY(x,y:byte);
begin
GotoXY(x,y);
end;
procedure WriteAT(x,y,a:byte;ch:char);
begin
with ScrPtr^[y,x] do
begin
attr := a;
chr := ch;
end;
end;
procedure GetXY(var x,y:byte);
begin
x := WhereX;
y := WhereY;
end;
procedure FillArea(x1,y1,x2,y2,a:byte;ch:char);
var
w,z : byte;
begin
for w := y1 to y2 do
for z := x1 to x2 do
WriteAT(z,w,a,ch);
end;
procedure Scroll(dir,x1,y1,x2,y2,n,a:byte);
var
t : byte;
begin
if n = 0 then
begin
FillArea(x1,y1,x2,y2,a,' ');
exit;
end;
case dir of
1 : begin { up }
if n > succ(y2-y1) then n := succ(y2-y1);
for t := y1+n to y2 do
Move(ScrPtr^[t,x1], ScrPtr^[t-n,x1], succ(x2-x1)*2); { move a line }
FillArea(x1,succ(y2-n),x2,y2,a,' ');
end;
2 : begin { down }
if n > succ(y2-y1) then n := succ(y2-y1);
for t := y2-n downto y1 do
Move(ScrPtr^[t,x1], ScrPtr^[t+n,x1], succ(x2-x1)*2); { move a line }
FillArea(x1,y1,x2,pred(y1+n),a,' ');
end;
3 : begin { left }
if n > succ(x2-x1) then n := succ(x2-x1);
for t := y1 to y2 do
Move(ScrPtr^[t,x1+n], ScrPtr^[t,x1], succ(x2-(x1+n))*2);
FillArea(succ(x2-n),y1,x2,y2,a,' ');
end;
4 : begin { right }
if n > succ(x2-x1) then n := succ(x2-x1);
for t := y1 to y2 do
Move(ScrPtr^[t,x1], ScrPtr^[t,x1+n], succ(x2-(x1+n))*2);
FillArea(x1,y1,pred(x1+n),y2,a,' ');
end;
end; { case dir }
end;
procedure GetScrChar(x,y:byte;var a:byte;var c:char);
begin
with ScrPtr^[y,x] do
begin
a := attr;
c := chr;
end;
end;
procedure HighArea(x1,y1,x2,y2,a:byte);
var
i,j,m : byte;
c : char;
begin
for i := x1 to x2 do
for j := y1 to y2 do
begin
GetScrChar(i,j,m,c);
WriteAT(i,j,a,c);
end;
end;
{$F-}
(* End Hook Definitions *)
procedure SetHooks;
begin
{ Query_Hook := <defualt null hook for this application> }
HighAreah := HighArea;
GetATh := GetScrChar;
FillAreah := FillArea;
Scrollh := Scroll;
GotoXYh := SetXY;
WriteATh := WriteAT;
end;
function UpStr(s:string): string;
var
ns : string;
i : integer;
begin
for i := 1 to length(s) do
ns[i] := upcase(s[i]);
ns[0] := s[0];
UpStr := ns;
end;
procedure Help;
begin
Writeln('A-0 Demo Copr. 1991 Greg Smith');
Writeln;
Writeln('Usage: A0DEMO [params] input_file [params]');
Writeln;
Writeln(' parameters:');
Writeln(' /ANSI Start with ANSI child active.');
Writeln(' /SLOW Slow down emulation for viewing.');
halt;
end;
var
fname : pathstr;
const
slowdown : byte = 0; { milliseconds between characters. }
procedure ProcessParams;
const
Prms = '/ANSI/SLOW/?/HELP';
var
i,p : integer;
begin
p := paramcount;
while p > 0 do
begin
i := pos(UpStr(ParamStr(p)),Prms);
case i of
1 : ANSI_Only;
6 : Slowdown := 2; { set to ms between chars. }
11..13 : Help;
else
fname := ParamStr(p);
end; { case }
dec(p);
end; { while }
end; { processed in reverse so that first non-parameter is the filename }
Procedure ProgBody;
var
f : file;
buf : Array[1..1024] of char;
i,z : word;
begin
Assign(Output,''); Rewrite(Output);
Assign(Input,''); Reset(Input);
fname := '';
SetScrPtr;
SetHooks;
ProcessParams;
if fname = '' then Help;
FillArea(1,1,80,25,0,' '); { Clear Screen }
Assign(f,fname);
Reset(f,1);
if slowdown = 0 then
repeat
BlockRead(f,buf,1024,z);
for i := 1 to z do AVTInterp(buf[i]);
until EOF(f)
else
repeat
BlockRead(f,buf,1024,z);
for i := 1 to z do
begin
Delay(slowdown);
AVTInterp(buf[i]);
end;
until EOF(f); { end else }
end;
begin
ProgBody;
end.